home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Yerk 3.6.6 / Toolbox Classes / Ctl < prev    next >
Encoding:
Text File  |  1993-09-27  |  5.1 KB  |  165 lines  |  [TEXT/YERK]
  1. \  4/16/84  NDI Version 1.0
  2. \  5/07/84  NDI Convert to CALL:
  3. \  6/22/84  NDI add INIT:, change new, modify struct
  4. \  8/19/84  CBD added FindCtl
  5. \ 12/16/84  cbd VsCtl is separate from Control
  6. \  1/31/87    rfl added myWindow and myValue; new: window: put: get: classinit:
  7. \  6/02/87  rfl changed width of rect to 20+ in x from 17+
  8. \  1/19/88    rfl added getnew settitle gettitle
  9. \  9/01/88    rfl    changed back to 17 and added dim: undim:
  10. \  9/11/88    rfl    dim: to disable, undim: to enable:
  11. \ 12/14/90    rfl    removed initfont in new: and getnew: and added saveFont, restFont
  12. \ 12/18/91    rfl    resID now IVAR..getnew requires nothing on stack. must window: first
  13. \  6/24/92    rfl    putwindow and getwindow methods added for consistency to other code
  14. \  8/09/92    rfl    added frame: to draw default frame around the control
  15. \  5/13/93    rfl    protected getnew:
  16. \  6/17/93    rfl    added offset:
  17. \  9/25/93    rfl    added pushport, set: window, popport for new: (for interactive cosmetic)
  18.  
  19. Decimal
  20.  
  21. 0 variable fontBuf 4 allot
  22. : savefont ( wind -- ) 68 + fontBuf 8 cmove ;
  23. : restfont ( wind -- ) fontBuf swap 68 + 8 cmove ;
  24.  
  25. \ ( ctlhndl -- objptr )  get rel ptr to ctl obj from ctl rec
  26. : Get-ctl-obj     0 swap  call GetCRefCon ;
  27.  
  28. \ ( objptr ctlhndl -- )  set rel ptr to ctl obj in ctl rec
  29. : Set-ctl-obj     swap call SetCRefCon ;
  30.  
  31. \ ( addr len -- width )  return width of string in current font
  32. : tWidth  str255 >R word0 R> call StringWidth word0  ;
  33.  
  34.  0 constant buttonID    \ control types
  35.  1 constant checkID
  36.  2 constant radioID
  37. 16 constant VsID
  38.  
  39. \ basic control class for simple controls - buttons, etc.
  40. :CLASS Control  <Super Object
  41.  
  42.     Int        procid
  43.     Handle    ctlHndl
  44.     Var        action
  45.     Int        myValue
  46.     Var        myWindow
  47.     Int        resID
  48.  
  49.     \ ( n -- )
  50.     :M PUTRESID: put: resID ;M
  51.  
  52.     \ ( part# -- )  perform action for control
  53.     :M  EXEC:  IF exec: action THEN  ;M
  54.  
  55.     \ ( -- l t r b )  stack bounds rectangle
  56.     :M  GETRECT:  ptr: ctlhndl  8+  get: rect  ;M
  57.  
  58.     \ ( -- )  cause the control to be drawn
  59.     :M  UPDATE:   Ptr: CtlHndl  8+  +base call InvalRect   ;M
  60.  
  61.     :M  HIDE:   Get: Ctlhndl   call HideControl    ;M
  62.  
  63.     :M  SHOW:   Get: Ctlhndl   call ShowControl    ;M
  64.  
  65.     \ ( x y -- )  Move control to x,y location
  66.     :M  MOVETO:  pack get: ctlhndl swap call MoveControl ;M
  67.  
  68.     \ ( dx dy -- ) Offset from current x,y by dx,dy
  69.     :M  OFFSET: { dx dy \ x y -- } getRect: self 2drop -> y -> x
  70.         dx x + dy y + moveto: self ;M
  71.  
  72.     \ ( w h -- )  set width, height of control's rect
  73.     :M  SIZE:  pack get: ctlhndl swap call SizeControl  ;M
  74.  
  75.     \ ( procid -- )  initialize
  76.     :M  INIT:  put: procid   ;M
  77.  
  78.     \ ( window -- ) use this to initialize the owning window
  79.     :M    WINDOW:  put: myWindow ;M
  80.  
  81.     :M  PUTWINDOW: put: myWindow ;M
  82.  
  83.     :M  GETWINDOW: get: myWindow ;M
  84.  
  85.     \ ( cfa -- )  set the action for this control
  86.     :M  ACTIONS:  put: action  ;M
  87.  
  88.     \ ( value -- )  set ctl value
  89.     :M    PUT:  { theVal -- } alive: [ obj: myWindow ]
  90.         IF theVal get: ctlhndl  swap makeint call SetCtlValue THEN
  91.         theVal put: myValue ;M
  92.  
  93.     \ ( -- val)  some ctls may need original value, eg scroll bar
  94.     :M    GET:  alive: [ obj: myWindow ]
  95.         IF w 0 get: ctlhndl call getCtlValue word0
  96.         ELSE get: myValue
  97.         THEN ;M
  98.  
  99.     \ build a control on the heap
  100.     :M  NEW:  { x y addr len theWind \ tWid -- }
  101.         theWind saveFont pushPort set: theWind
  102.         get: procID 8 and 0=    \ window font if true
  103.         IF  0 tFont 12 tSize THEN  addr len tWidth -> tWid    \ width of title
  104.         x y  x tWid + 17 + y 17 + put: tempRect
  105.         0 abs: theWind  Abs: tempRect addr len str255
  106.         w 256 word0 word0 w 1  Int: procid  ^base
  107.         call NewControl put: ctlhndl
  108.         ^base get: ctlhndl set-ctl-obj
  109.         theWind put: myWindow get: myValue put: self theWind restFont popPort ;M
  110.  
  111.      :M getnew: { \ theWind -- } get: myWindow -> theWind
  112.         theWind 0= classerr" 157 theWind saveFont
  113.         0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  114.         put: ctlhndl
  115.         ^base get: ctlhndl set-ctl-obj
  116.         theWind put: myWindow get: myValue put: self theWind restFont ;M
  117.  
  118.     \ ( -- ctlhndl )
  119.     :M  HANDLE:  Get: CtlHndl  ;M
  120.  
  121.     \ ( hiliteState -- )  Hilite a part or entire control
  122.     :M  HILITE:  get: ctlhndl  swap makeInt
  123.         call HiliteControl    ;M
  124.  
  125.     :M  DISABLE: -1 hilite: self ;M
  126.     :M  ENABLE: 0 hilite: self ;M
  127.  
  128.     \ draws a border around a control to signify the default button.
  129.     :M  FRAME: pushPort set: [ obj: myWindow ] 3 3 pack call PenSize
  130.          getRect: self put: tempRect
  131.          -4 -4 inset: tempRect
  132.          abs: tempRect 16 16 pack call FrameRoundRect call penNormal popPort ;M
  133.  
  134.     \ ( addr len -- )
  135.     :M  setTitle: str255 get: ctlhndl swap call setCTitle ;M
  136.  
  137.     \ ( -- addr len )
  138.     :M  getTitle: get: ctlhndl pad +base call getCTitle pad count ;M
  139.     \ ( -- )
  140.     :M  CLOSE:    Get: Ctlhndl call DisposControl  ;M
  141.  
  142.     \ ( -- )  set default control to a standard button
  143.     :M  CLASSINIT:  buttonID init: self 'c null actions: self  ;M
  144.  
  145.     \ ( ^wind -- )  show an example button
  146.     :M  EXAMPLE: { thewind -- }  200 100 " Button"
  147.         theWind new: self  update: self  ;M
  148.  
  149. ;CLASS
  150.  
  151. 0 variable  theCtl
  152.  
  153. \ control part codes
  154. 10  constant inButton        \ simple button
  155. 11  constant inCheckBox        \ check or radio
  156. 129 constant inThumb
  157. 20  constant inUpButton        \ up arrow in scroll bar
  158. 21  constant inDownButton    \ down arrow
  159. 22  constant inPageUp
  160. 23  constant inPageDown
  161.  
  162. \ add to ID if title in application font
  163. 8 constant useWFont
  164.  
  165.